Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue61/System/FTPReader.pas

Pascal/Delphi Source File | 2000-08-07 | 7.2 KB | 213 lines

unit FTPReader;

interface

uses Windows, WinINet, SysUtils, Classes, Dialogs;

const
    BufSize = $1000;

type
    TFTPFileReader = class;

    TFTPFileReaderThread = class (TThread)
    private
        Owner: TFTPFileReader;
        procedure DoProgress;
    public
        procedure Execute; override;
    end;

    TFTPFileReader = class (TObject)
    private
        fNetConnection: HInternet;
        fFTPSession: HInternet;
        fFileHandle: HInternet;
        fSourceFileName: String;
        fServerName: String;
        fDestStream: TFileStream;
        fDestFileName: String;
        fUserName: String;
        fPassword: String;
        fFileSize: Integer;
        fOwnFTPSession: Boolean;
        fServerPort: Integer;
        fTotalBytesRead: Integer;
        fOnProgress: TNotifyEvent;
        fCompletionString: String;
        fOnCompletetion: TNotifyEvent;
        fThread: TFTPFileReaderThread;
        fBuffer: array [0..BufSize - 1] of Char;
        procedure Cleanup (Fail: Boolean);
        procedure Panic (const Message: String);
        function StartSession: Boolean;
        procedure ThreadTerminated (Sender: TObject);
    public
        destructor Destroy; override;
        procedure Execute;
        procedure CancelTransfer;
        property FileSize: Integer read fFileSize;
        property TotalBytesRead: Integer read fTotalBytesRead;
        property CompletionString: String read fCompletionString;
        property NetConnection: HInternet read fNetConnection write fNetConnection;
        property FTPSession: HInternet read fFTPSession write fFTPSession;
        property SourceFileName: String read fSourceFileName write fSourceFileName;
        property DestFileName: String read fDestFileName write fDestFileName;
        property ServerName: String read fServerName write fServerName;
        property ServerPort: Integer read fServerPort write fServerPort;
        property OnProgress: TNotifyEvent read fOnProgress write fOnProgress;
        property OnCompletion: TNotifyEvent read fOnCompletetion write fOnCompletetion;
    end;

implementation

// TFTPFileReader

destructor TFTPFileReader.Destroy;
begin
    Cleanup (False);
    Inherited Destroy;
end;

procedure TFTPFileReader.Cleanup (Fail: Boolean);
begin
    // Close the destination file stream if open;
    fDestStream.Free;
    fDestStream := Nil;
    if Fail then DeleteFile (fDestFileName);

    // Close the source file if its open
    if fFileHandle <> Nil then begin
        InternetCloseHandle (fFileHandle);
        fFileHandle := Nil;
    end;

    // Tear down the FTP session, if any
    if fOwnFTPSession and (fFTPSession <> Nil) then begin
        InternetCloseHandle (fFTPSession);
        fFTPSession := Nil;
        fOwnFTPSession := False;
    end;
end;

procedure TFTPFileReader.Panic (const Message: String);
begin
    Cleanup (True);
    raise Exception.Create (ClassName + ': ' + Message);
end;

procedure TFTPFileReader.CancelTransfer;
begin
    Cleanup (True);
end;

function TFTPFileReader.StartSession: Boolean;
var
    FindHandle: HInternet;
    FindData: TWin32FindData;
    szUserName, szPassword: PChar;
begin
    // Do we need to create an FTP session ?

    if fFTPSession = Nil then begin
        if fNetConnection = Nil then Panic ('No Network connection specified');
        if (fUserName = '') or (fPassword = '') then begin
            szUserName := Nil;  szPassword := Nil;
        end else begin
            szUserName := @fUserName [1];  szPassword := @fPassword [1];
        end;

        fFTPSession := InternetConnect (fNetConnection, PChar (fServerName), fServerPort,
                                        szUserName, szPassword, Internet_Service_FTP, 0, 0);
        if fFTPSession = Nil then Panic ('Can''t create an FTP session');
        fOwnFTPSession := True;
    end;

    // We've got an FTP session.  How big is the file?
    FindHandle := FtpFindFirstFile (fFTPSession, PChar (fSourceFileName), FindData, 0, 0);
    if FindHandle <> Nil then begin
        fFileSize := FindData.nFileSizeLow;
        InternetCloseHandle (FindHandle);
    end;

    // Now, try and open the file for transfer
    fFileHandle := FtpOpenFile (fFTPSession, PChar (fSourceFileName), Generic_Read, Ftp_Transfer_Type_Binary, 0);
    Result := fFileHandle <> Nil;
end;

procedure TFTPFileReader.Execute;
begin
    // Perform all needed sanity checks....
    if fServerName = '' then Panic ('No server name specified');
    if fSourceFileName = '' then Panic ('No source filename specified');
    if fDestFileName = '' then Panic ('No destination filename specified');
    if fServerPort = 0 then fServerPort := Internet_Default_FTP_Port;
    // So far so good....now create an FTP session
    if not StartSession then Panic ('Requested file not found') else begin
        // Thunderbirds are go!  It's time to create the background thread,
        // create the source file and start rolling....
        try
            fDestStream := TFileStream.Create (fDestFileName, fmCreate);
        except
            Panic ('Can''t create destination file');
        end;

        fThread := TFTPFileReaderThread.Create (True);
        fThread.FreeOnTerminate := True;
        fThread.OnTerminate := ThreadTerminated;
        fThread.Owner := Self;
        fThread.Resume;
    end;
end;

procedure TFTPFileReader.ThreadTerminated (Sender: TObject);
begin
    if Assigned (OnCompletion) then OnCompletion (Self);
end;

// TFTPFileReaderThread

procedure TFTPFileReaderThread.DoProgress;
begin
    if Assigned (Owner.OnProgress) then Owner.OnProgress (Owner);
end;

procedure TFTPFileReaderThread.Execute;
var
    BytesRead: DWord;
    ErrNum, BuffSize: DWord;
    szBuff: array [0..1024] of Char;
begin
    while not Terminated do begin
        BytesRead := 0;
        if InternetReadFile (Owner.fFileHandle, @Owner.fBuffer, sizeof (Owner.fBuffer), BytesRead) then begin
            // If we've got some more data, write it to destination file
            if (BytesRead > 0) and (BytesRead <= sizeof (Owner.fBuffer)) then begin
                Owner.fDestStream.Write (Owner.fBuffer, BytesRead);
                // Update progress info......
                Owner.fTotalBytesRead := Owner.fTotalBytesRead + Integer (BytesRead);
                Synchronize (DoProgress);
            end;

            // If we didn't get any data, but InternetReadFile returned True, then it's EOF
            // Just terminate the thread by leaving Execute.
            if BytesRead = 0 then begin
                Owner.fCompletionString := 'OK';
                Exit;
            end;
        end else begin
            // It looks bad.  InternetReadFile has returned False which basically means its
            // screwed up.  Get the last response string from the server and pass it back.
            BuffSize := sizeof (szBuff);  Owner.fCompletionString := 'Unknown Error';
            if InternetGetLastResponseInfo (ErrNum, szBuff, BuffSize) then
                if (BuffSize > 0) and (szBuff [0] <> #0) then
                    Owner.fCompletionString := szBuff;
            // We're out'a here......
            Exit;
        end;
    end;
end;

end.